Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/hdebug.zip/HDEBUG10.PAS

Pascal/Delphi Source File | 1991-10-20 | 6KB | 188 lines

Unit HDebug10;

{$O-}    {  The routines Allocation and Deallocation are called through
            pointers to their addresses.  If you have to overlay, place
            these two procedures in a non-overlaid unit of their own.        }

{----------------------------------------------------------------------------}

interface

  uses
    CRT,       {  color constants   }
    Heap,      {  Heap Interceptor  }
    MapInfo;

  var
    HDMessage : String;       {  WATCH this variable for more information.   }

    {  Heap request interrupt handlers  }

{$F+}
  Procedure Allocating(Size : Word; BlockAddr,CallAddr : Pointer);
  Procedure Deallocating(Size : Word; BlockAddr,CallAddr : Pointer);
{$F-}

{----------------------------------------------------------------------------}

implementation

const
  VideoSegment = $B800;           {  $B000 for monochrome monitors.          }
  HeapGranularity = 8;            {  Turbo Pascal 6.0 heap granularity.      }

var
  HeapSize,                       {  Used to calculate the size of the heap  }
  HeapBottom,                     {  and the position of pointers within it. }
  HeapTop : LongInt;
  NumHeapPointers : Word;

  UserHeapCount,                  {  Counts heap variables created.          }
  Reference : Word;               {  Incremented with each heap interception.}

{----------------------------------------------------------------------------}

    {  Represent an integer as a string.  }

  Function IntStr(A : Integer) : String;
    var
      Temp : String;
    Begin
      Str(A,Temp);
      IntStr := Temp;
    End;

{----------------------------------------------------------------------------}

    {  Represent a pointer as a string.  }

Function PointerStr(P : Pointer) : String;
  Begin
    PointerStr := 'PTR('+HexPtrStr(P)+')';
  End;

{----------------------------------------------------------------------------}

    {  Convert a pointer to a longint.  }

Function Pointer_To_LongInt(P : Pointer) : LongInt;
  type
    PtrRec = record
      Lo,Hi : Word;
    end;
  Begin
    Pointer_To_LongInt := LongInt(PtrRec(P).Hi)*16+PtrRec(P).Lo;
  End;

{----------------------------------------------------------------------------}

    {  Display an urgent message on the screen or in the debugger.
       If a string begins with an '!', it will be displayed on the screen.   }

Procedure Message(S : String);
  const
    MessageAttr = Red*16+Yellow;          {  Attention getting, ugly colors. }
  var
    SaveLine : Array[1..255] of Word;     {  Used to restore the screen.     }
    VideoLine : Array[1..255] of Word absolute VideoSegment:0;
                                          {  First video line.               }
    i,L : Byte;
  Begin
    if (S[1] = '!') then                  {  If urgent, place on the screen. }
      begin
        L := Length(S);
        Move(VideoLine,SaveLine,L*SizeOf(Word));
        for i := 1 to L-1 do
          VideoLine[i] := MessageAttr*256+Byte(S[i+1]);
        ReadLn;
        Move(SaveLine,VideoLine,L*SizeOf(Word));  {  Restore the screen.     }
      end
    else
      HDMessage := S;
  End;

{----------------------------------------------------------------------------}

    {  Map a pointer within the heap onto the heap map.  }

Function HeapPointer_Ordinate(P : Pointer) : LongInt;
  var
    HeapPointer : LongInt;
  Begin
    if (P = nil) then
      HeapPointer_Ordinate := 0
    else
      begin
        HeapPointer := Pointer_To_LongInt(P);
        if ((HeapPointer >= HeapBottom) and (HeapPointer <= HeapTop)) then
          HeapPointer_Ordinate := (HeapPointer div HeapGranularity)-
                                  (HeapBottom div HeapGranularity)+1
        else
          Message('!'+PointerStr(P)+' is not within the heap.');
      end;
  End;

{----------------------------------------------------------------------------}

Procedure Allocating(Size : Word; BlockAddr,CallAddr : Pointer);
  var
    OldReference : Word;
    Ordinate : LongInt;
    Allocate : Boolean;
  Begin
    Inc(UserHeapCount);
    Inc(Reference);
    if FatalHeapError and InterceptFatalHeapErrors then
      begin
        Message('!Allocation error detected.');
        Enter_Debugger(CallAddr);
        Message('!Found in unit '+UnitName+', line '+IntStr(CurrentLineNumber)+', address '+PointerStr(CallAddr));
      end;
  End;

{----------------------------------------------------------------------------}

Procedure Deallocating(Size : Word; BlockAddr,CallAddr : Pointer);
  var
    Ordinate : LongInt;
    Original_Size : Word;
    Deallocate : Boolean;

  Begin
    Dec(UserHeapCount);
    Inc(Reference);
    if FatalHeapError and InterceptFatalHeapErrors then
      begin
        Message('!Deallocation error detected.');
        Enter_Debugger(CallAddr);
        Message('!Found in unit '+UnitName+', line '+IntStr(CurrentLineNumber)+', address '+PointerStr(CallAddr));
      end;
  End;

{----------------------------------------------------------------------------}

BEGIN

    {  Assign procedures to each of the interrupt handlers.  }

  Allocation_Handler   := @Allocating;
  Deallocation_Handler := @Deallocating;

    {  Initialize  }

  UserHeapCount := 0;
  Reference     := 0;

    {  Get the dimensions of the heap as soon as possible.  }

  HeapBottom      := Pointer_To_LongInt(HeapOrg);
  HeapTop         := Pointer_To_LongInt(HeapEnd);
  HeapSize        := HeapTop-HeapBottom;
  NumHeapPointers := HeapSize div HeapGranularity;

  HDMessage := '';
END.

{----------------------------------------------------------------------------}